home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Games of Daze
/
Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso
/
x2ftp
/
msdos
/
ai
/
fuzzy
/
do_reser.b
< prev
next >
Wrap
Text File
|
1986-11-29
|
22KB
|
688 lines
-------------------------------------------------------------------------------
-- --
-- Separate Unit: Do_reserved -- process reserved predicates for Prover --
-- --
-- Author: Bradley L. Richards --
-- --
-- Version Date Notes . . . --
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --
-- 1.0 - - - - - Never existed. First version implemented after --
-- Parser et al reached version 2.0 --
-- 2.0 20 Jun 86 Initial Version --
-- 2.05 13 Jul 86 Split into separate spec and package files --
-- 2.1 21 Jul 86 Demonstration version -- initial predicates --
-- implemented; initial debugging completed --
-- 2.2 28 Jul 86 Initial operational version -- 20 predicates --
-- implemented, plus lots of squashed bugs --
-- 2.3 19 Aug 86 Use AVL trees for rule_base, add many reserved --
-- predicates, and split output routines into --
-- package print_stuff. --
-- 2.4 31 Aug 86 Do_reserved split out from Prover --
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --
-- --
-- Description: The procedure Do_reserved accepts Fuzzy Prolog reserved --
-- predicates from Seek and processes them. Most predicates have --
-- their own subprocedure, but a few (e.g. asserta/assertz) are --
-- combined. After Do_reserved, all routines appear alphabetically. --
-- --
-------------------------------------------------------------------------------
separate(prover)
procedure do_reserved( pred, goal_tree : AST_ptr; result_node : out AST_ptr;
bindings : in out binding_list; level : natural;
failed : in out boolean ) is
new_rule, new_rules, temp : AST_ptr;
template : constant AST_ptr := new AST'(implication,
new AST'(predicate, null, null), null, null, null);
a_template : constant argument_ptr := new argument'(float_num, null, 0.0);
file_ptr, value, value2, read_value : argument_ptr;
temp_bindings : binding_list;
int_arg, value_level, value2_level : integer;
result_done : boolean := false;
duplicate, not_found, unified : boolean;
result : float := 0.0;
procedure dr_assert is
--
-- Eval -- This set of three routines evalutes arguments. Eval_args
-- evalutes the arguments in a functor's argument list, and is
-- the main routine called by dr_assert. Eval evaluates a
-- single argument, and eval_list evaluates the contents of
-- a prolog list.
--
function eval_args( in_args : argument_ptr; bindings : binding_list;
level : natural ) return argument_ptr;
function eval_list( in_list : p_list_ptr; bindings : binding_list;
level : natural ) return p_list_ptr;
function eval( in_arg : argument_ptr; bindings : binding_list;
level : natural ) return argument_ptr is
value : argument_ptr;
value_level : natural;
begin
lookup(in_arg, level, bindings, value, value_level);
if value.is_a = predicate then
return new argument'(predicate, null, value.name,
eval_args(value.p_arguments, bindings, value_level));
elsif value.is_a = prolog_list then
return new argument'(prolog_list, null,
eval_list(value.list, bindings, value_level));
else
return new argument'(value.all);
end if;
end eval;
function eval_args( in_args : argument_ptr; bindings : binding_list;
level : natural ) return argument_ptr is
args : argument_ptr := in_args;
new_arg : argument_ptr := null;
new_args, temp : argument_ptr;
begin
while args /= null loop
temp := eval(args, bindings, level);
if new_arg = null then -- this is the first argument
new_arg := temp;
new_args := new_arg;
else
new_arg.next_arg := temp;
new_arg := new_arg.next_arg;
end if;
new_arg.next_arg := null;
args := args.next_arg;
end loop;
return new_args;
end eval_args;
function eval_list( in_list : p_list_ptr; bindings : binding_list;
level : natural ) return p_list_ptr is
elts : p_list_ptr := in_list;
new_elt : p_list_ptr := null;
new_elts, temp : p_list_ptr;
begin
while elts /= null loop
--
-- Ada, in its infinite error checking, requires the following
-- useless if statement in order to keep the discriminate static
--
if elts.has_tail then
temp := new p_list'(true, eval(elts.elt, bindings, level), null);
else
temp := new p_list'(false, eval(elts.elt, bindings, level), null);
end if;
if new_elt = null then -- this is the first argument
new_elt := temp;
new_elts := new_elt;
else
new_elt.next_elt := temp;
new_elt := new_elt.next_elt;
end if;
if elts.has_tail then
new_elt.tail := eval(elts.tail, bindings, level);
exit;
else
elts := elts.next_elt;
end if;
end loop;
return new_elts;
end eval_list;
begin -- dr_assert
if (pred.r_arguments = null) then
error(no_pointer,"ASSERTA/Z called without any arguments");
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
if pred.r_arguments.next_arg = null then -- use default truth of 1.0
a_template.fp_num := 1.0;
value2 := a_template;
else
lookup(pred.r_arguments.next_arg,level,bindings,value2,value2_level);
end if;
if value.is_a /= predicate then
error(no_pointer, "first argument to ASSERTA/Z must be a functor");
failed := true;
elsif (value2.is_a /= float_num) or else (value2.fp_num < 0.0) or else
(value2.fp_num > 1.0) then
error(no_pointer,"2nd argument to ASSERTA/Z must be a fuzzy value");
failed := true;
else
new_rule :=
new AST'(implication,
new AST'(predicate, value.name,
eval_args(value.p_arguments,bindings,value_level)),
new AST'(fuzzy_value, value2.fp_num), null, null);
add_node(rule_base, new_rule, duplicate);
if duplicate then
temp := fetch_node(rule_base, new_rule);
if temp = null then
update_node(rule_base, new_rule, not_found);
if not_found then
raise prover_error;
end if;
else
if pred.predicate = rw_asserta then
new_rule.next := temp;
temp.prev := new_rule;
update_node(rule_base, new_rule, not_found);
if not_found then
raise prover_error;
end if;
else
while temp.next /= null loop
temp := temp.next;
end loop;
temp.next := new_rule;
new_rule.prev := temp;
end if;
end if;
end if;
result := 1.0;
end if;
end if;
end dr_assert;
procedure dr_call is
begin
if pred.r_arguments = null then
error(no_pointer,"CALL requires one argument");
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
if (value.is_a /= predicate) then
error(no_pointer,"argument to CALL must be a functor");
failed := true;
else
result_node :=
new AST'(resolution_marker, value_level, threshold,
new AST'(predicate, value.name, value.p_arguments));
result_done := true;
end if;
end if;
end dr_call;
procedure dr_consult is
rule_count : integer;
--
-- Append -- Used by consult to add rules to rule base.
--
procedure append(rule_base : in out tree_ptr; in_rules : AST_ptr;
rule_count : out integer) is
duplicate : boolean;
next_rule, node : AST_ptr;
new_rules : AST_ptr := in_rules;
counter : integer := 0;
begin
while new_rules /= null loop
next_rule := new_rules.next;
new_rules.prev := null;
new_rules.next := null;
add_node(rule_base, new_rules, duplicate);
if duplicate then
node := fetch_node( rule_base, new_rules );
if node /= null then
while node.next /= null loop
node := node.next;
end loop;
node.next := new_rules;
new_rules.prev := node;
else
raise prover_error;
end if;
end if;
new_rules := next_rule;
counter := counter + 1;
end loop;
rule_count := counter;
end append;
begin -- dr_consult
file_ptr := pred.r_arguments;
while file_ptr /= null loop
if file_ptr.is_a = predicate then
put(file_ptr.name.name);
start_parser(file_ptr.name.name, "");
parse_file(new_rules);
stop_parser;
if number_of_errors = 0 then
append(rule_base, new_rules, rule_count);
result := 1.0;
put(" has "); put(rule_count, 1); put(" rules");
else
put(file_ptr.name.name & " ignored");
failed := true;
end if;
new_line;
else
put_line("invalid file name");
failed := true;
end if;
file_ptr := file_ptr.next_arg;
end loop;
end dr_consult;
procedure dr_fuzzy is
begin
if pred.r_arguments = null then
error(no_pointer,"FUZZY requires one argument");
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
if value.is_a = float_num then
if (value.fp_num < 0.0) or (value.fp_num > 1.0) then
error(no_pointer, "value to FUZZY out of range");
failed := true;
else
result := value.fp_num;
end if;
elsif value.is_a = variable then
a_template.fp_num := current_truth;
unify_arg(value, a_template, value_level, level, bindings, unified);
result := current_truth;
if not unified then
raise prover_error;
end if;
else
error(no_pointer, "invalid node type to FUZZY");
failed := true;
end if;
end if;
end dr_fuzzy;
procedure dr_listing is
begin
if pred.r_arguments = null then
error(no_pointer,"LISTING requires one argument");
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
if value.is_a /= predicate then
error(no_pointer,"argument to LISTING must be a functor");
else
template.head.name := value.name;
temp := fetch_node(rule_base, template);
if temp /= null then
while temp /= null loop
print_clause(temp);
temp := temp.next;
end loop;
result := 1.0;
end if;
end if;
end if;
end dr_listing;
procedure dr_log is
begin
if (pred.r_arguments = null) or else
(pred.r_arguments.next_arg = null) then
error(no_pointer, "LN/LOG requires two arguments");
failed := true;
else
lookup(pred.r_arguments,level,bindings,value,value_level);
lookup(pred.r_arguments.next_arg,level,bindings,value2,value2_level);
if value.is_a = variable then
case value2.is_a is
when variable =>
error(no_pointer,"both arguments to LN/LOG uninstantiated");
failed := true;
when float_num =>
if pred.predicate = rw_ln then
a_template.fp_num := exp(value2.fp_num);
else -- rw_log
a_template.fp_num := 10.0 ** value2.fp_num;
end if;
when integer_num =>
if pred.predicate = rw_ln then
a_template.fp_num := exp(float(value2.int_num));
else -- rw_log
a_template.fp_num := 10.0 ** float(value2.int_num);
end if;
when others =>
error(no_pointer,"2nd argument to LN/LOG is an invalid type");
failed := true;
end case;
if not failed then
unify_arg(value,a_template,value_level,level,bindings,unified);
if unified then
result := 1.0;
else
raise prover_error;
end if;
end if;
elsif (value.is_a = float_num) or (value.is_a = integer_num) then
if value.is_a = float_num then
if pred.predicate = rw_ln then
a_template.fp_num := nat_log(value.fp_num);
else -- rw_log
a_template.fp_num := com_log(value.fp_num);
end if;
else -- integer_num
if pred.predicate = rw_ln then
a_template.fp_num := nat_log(float(value.int_num));
else -- rw_log
a_template.fp_num := com_log(float(value.int_num));
end if;
end if;
case value2.is_a is
when variable =>
unify_arg(value2,a_template,value2_level,level,bindings,unified);
if unified then
result := 1.0;
else
raise prover_error;
end if;
when float_num =>
if a_template.fp_num = value2.fp_num then
result := 1.0;
end if;
when integer_num =>
if a_template.fp_num = float(value2.int_num) then
result := 1.0;
end if;
when others =>
error(no_pointer,"2nd argument to LN/LOG is an invalid type");
failed := true;
end case;
else
error(no_pointer,"1st argument to LN/LOG is an invalid type");
failed := true;
end if;
end if;
end dr_log;
procedure dr_parse is
begin
file_ptr := pred.r_arguments;
while file_ptr /= null loop
if file_ptr.is_a = predicate then
put(file_ptr.name.name & ' ');
start_parser(file_ptr.name.name, (file_ptr.name.name & ".lst"));
parse_file(new_rules);
stop_parser;
put_line("contains:");
put(number_of_errors); put_line(" errors");
put(number_of_warnings); put_line(" warnings");
put(number_of_notes); put_line(" notes");
result := 1.0;
else
error(no_pointer, "invalid file name");
failed := true;
end if;
file_ptr := file_ptr.next_arg;
end loop;
end dr_parse;
procedure dr_put_tab is
begin
if pred.r_arguments = null then
error(no_pointer,(pred.name.name & " requires one argument"));
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
if (value.is_a /= integer_num) and (value.is_a /= float_num) then
if pred.predicate = rw_put then
error(no_pointer, "nonnumeric argument to PUT");
else
error(no_pointer, "nonnumeric argument to TAB");
end if;
failed := true;
else
if value.is_a = integer_num then
int_arg := value.int_num;
else -- fp
int_arg := integer(value.fp_num + 0.00001);
end if;
if pred.predicate = rw_put then
put(character'val(int_arg));
else
for i in 1..int_arg loop
put(' ');
end loop;
end if;
result := 1.0;
end if;
end if;
end dr_put_tab;
procedure dr_read is
eof : boolean;
begin
if pred.r_arguments = null then
error(no_pointer,"READ requires one argument");
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
start_parser("", "");
parse_read(read_value, eof);
stop_parser;
if (number_of_errors = 0) and (not eof) then
unify_arg(value, read_value, value_level, level, bindings, unified);
if unified then
result := 1.0;
end if;
else
failed := true; -- errors have already been displayed to screen
end if;
end if;
end dr_read;
procedure dr_reset is
begin
release(rule_base);
rule_base := init_tree;
put_line("rule base reinitialized");
result := 1.0;
end dr_reset;
procedure dr_retract is
begin
--
-- This retract logic has one inherent, insidious bug. Clauses which
-- have been retracted from the rule base may still be pointed to by
-- db_ptr in various instantiations of Seek already on the call stack.
-- There appears to be no way to fix this without major program
-- restructuring. This problem should not arise too often, but
-- in hopes of mitigating potential damages RETRACT does not
-- deallocate retracted rules.
--
if pred.r_arguments = null then
error(no_pointer,"RETRACT requires one argument");
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
if value.is_a /= predicate then
error(no_pointer,"argument to RETRACT must be a functor");
failed := true;
else
template.head.name := value.name;
template.head.p_arguments := value.p_arguments;
temp := fetch_node(rule_base, template);
unified := false;
while temp /= null loop
temp_bindings := bindings;
unify(template.head, temp.head, value_level, integer'last,
temp_bindings, unified);
if unified then
bindings := temp_bindings;
exit;
else
release(temp_bindings, bindings); -- the bindings aren't valid
end if;
temp_bindings := bindings;
temp := temp.next;
end loop;
if unified then
if temp.prev = null then -- the first node, so must update
if temp.next = null then
delete_node(rule_base, temp, not_found);
else
temp.next.prev := null;
temp := temp.next;
update_node(rule_base, temp, not_found);
end if;
if not_found then
raise prover_error;
end if;
else
temp.prev.next := temp.next;
if temp.next /= null then
temp.next.prev := temp.prev;
end if;
end if;
result := 1.0;
else
failed := true;
end if;
end if;
end if;
end dr_retract;
procedure dr_threshold is
begin
if pred.r_arguments = null then
error(no_pointer,"THRESHOLD requires one argument");
failed := true;
else
lookup(pred.r_arguments, level, bindings, value, value_level);
if value.is_a = variable then -- set variable to current threshold
unify_arg(value, new argument'(float_num, null, threshold),
value_level, level, bindings, unified);
result := 1.0;
if not unified then
raise prover_error;
end if;
elsif value.is_a = float_num then -- set the search threshold
threshold := value.fp_num;
result_node := new AST'(threshold_marker, 1.0, threshold);
current_truth := 1.0; -- must complete our result here
result_done := true;
else
error(no_pointer, "invalid argument to THRESHOLD");
failed := true;
end if;
end if;
end dr_threshold;
procedure dr_trace is
begin
if pred.predicate = rw_trace then
trace(true);
else -- rw_notrace
trace(false);
end if;
result := 1.0;
end dr_trace;
procedure dr_types is
begin
lookup(pred.r_arguments, level, bindings, value, value_level);
result := 0.0;
case value.is_a is
when integer_num =>
if (pred.predicate = rw_integer) or
(pred.predicate = rw_number) or
(pred.predicate = rw_atomic) or
(pred.predicate = rw_nonvar) then
result := 1.0;
end if;
when float_num =>
if (pred.predicate = rw_float) or
(pred.predicate = rw_number) or
(pred.predicate = rw_atomic) or
(pred.predicate = rw_nonvar) then
result := 1.0;
end if;
when character_lit =>
if (pred.predicate = rw_atomic) or
(pred.predicate = rw_nonvar) then
result := 1.0;
end if;
when predicate =>
if (pred.predicate = rw_atom) or
(pred.predicate = rw_atomic) or
(pred.predicate = rw_nonvar) then
result := 1.0;
end if;
when prolog_list =>
if (pred.predicate = rw_nonvar) then
result := 1.0;
end if;
when variable =>
if (pred.predicate = rw_var) then
result := 1.0;
end if;
end case;
if result = 0.0 then
failed := true;
end if;
end dr_types;
begin -- do_reserved
--
-- Call the proper routine for this reserved word. A few very simple
-- cases are handled within this procedure (for example "cut").
--
case pred.predicate is
when cut => result := 1.0; -- "cut" logic really appears in Seek
when rw_asserta | rw_assertz => dr_assert;
when rw_call => dr_call;
when rw_consult => dr_consult;
when rw_fail => failed := true;
when rw_fuzzy => dr_fuzzy;
when rw_listing => dr_listing;
when rw_ln | rw_log => dr_log;
when rw_nl => new_line;
result := 1.0;
when rw_parse => dr_parse;
when rw_put | rw_tab => dr_put_tab;
when rw_read => dr_read;
when rw_repeat => result := 1.0; -- real logic appears in Seek
when rw_reset => dr_reset;
when rw_retract => dr_retract;
when rw_threshold => dr_threshold;
when rw_trace | rw_notrace => dr_trace;
when rw_true => result := 1.0;
when rw_var | rw_nonvar | rw_atom |
rw_atomic | rw_number | rw_integer | rw_float => dr_types;
when rw_write =>
print_argument(pred.r_arguments, bindings, level, no_quote);
result := 1.0;
when others => put(pred.predicate); new_line;
error(no_pointer, "reserved predicate not implemented");
failed := true;
end case;
if not result_done then
current_truth := result;
result_node := new AST'(fuzzy_value, result);
end if;
exception
when name_error => -- this happens in consult, parse, and reconsult
failed := true;
put_line("not found--predicate aborted at this point");
end do_reserved;
